home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / run-collections-iterate.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  19.7 KB  |  337 lines  |  [TEXT/gamI]
  1. tware agree to the terms and conditions set forth herein,
  2. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  3. ;* right and license under any changes, enhancements or extensions made to the
  4. ;* core functions of the software, including but not limited to those affording
  5. ;* compatibility with other hardware or software environments, but excluding
  6. ;* applications which incorporate this software.  Users further agree to use
  7. ;* their best efforts to return to Digital any such changes, enhancements or
  8. ;* extensions that they make and inform Digital of noteworthy uses of this
  9. ;* software.  Correspondence should be provided to Digital at:
  10. ;* 
  11. ;*            Director, Cambridge Research Lab
  12. ;*            Digital Equipment Corp
  13. ;*            One Kendall Square, Bldg 700
  14. ;*            Cambridge MA 02139
  15. ;* 
  16. ;* This software may be distributed (but not offered for sale or transferred
  17. ;* for compensation) to third parties, provided such third parties agree to
  18. ;* abide by the terms and conditions of this notice.
  19. ;* 
  20. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  21. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  22. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  23. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  24. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  25. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  26. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  27. ;* SOFTWARE.
  28.  
  29. ; $Id: runtime-collections-iterate.scm,v 1.20 1992/09/07 04:16:53 jmiller Exp $
  30.  
  31. ;;;;; Handles the iteration protocol of collections, including the method
  32. ;;;;; specializations for all collection types.
  33.  
  34. ;;;;
  35. ;;;; THE ITERATION PROTOCOL (page 122)
  36. ;;;; The specializations occur immediately after the definition of the
  37. ;;;; generic function.
  38.  
  39.  
  40.   ;; Implementation of iteration state:
  41.   ;;
  42.   ;; <EMPTY-LIST>: no states available
  43.   ;; <PAIR> and <LIST>: the object itself, with #F terminating
  44.   ;; <ARRAY>: array of index values, incrementing "odometer style"
  45.   ;; <TABLE>: pair of index into hash table and pointer to current
  46.   ;;          entry in bucket.  Pointer is actually the list whose car is the
  47.   ;;          key/element pair.   [state == (list hash-index bucket-left)]
  48.   ;; <BYTE-STRING>: inherits from <array>
  49.   ;; <STRING>: not handled, any user-specified subclass must supply
  50.   ;;           operations
  51.   ;; <DEQUE>: pointer to current entry
  52.   ;; <RANGE>: current value
  53.  
  54. (define dylan:next-state "define dylan:next-state")
  55. (define dylan:initial-state "define dylan:initial-state")
  56. (define dylan:current-element "define dylan:current-element")
  57. (define dylan:copy-state "define dylan:copy-state")
  58. (define dylan:final-state "define dylan:final-state")
  59. (define dylan:previous-state "define dylan:previous-state")
  60.  
  61. (let ()
  62.   ;;
  63.   ;; INITIAL-STATE
  64.   ;;
  65.   (set! dylan:initial-state
  66.     (dylan::generic-fn 'initial-state
  67.       one-collection
  68.       (lambda (collection)
  69.     (dylan-call
  70.      dylan:error
  71.      "initial-state -- not specialized for this type of collection"
  72.      collection))))
  73.   (add-method dylan:initial-state
  74.     (one-arg 'NULL <empty-list> (lambda (null) null #F)))
  75.   (add-method dylan:initial-state
  76.     (one-arg 'LIST <list> (lambda (list) list)))
  77.   (add-method dylan:initial-state
  78.     (one-arg 'ARRAY <array>
  79.       (lambda (array)
  80.     (let ((dimensions (dylan-call dylan:dimensions array)))
  81.       (if (all? positive? (iterate->list (lambda (x) x) dimensions))
  82.           (make-vector (length dimensions) 0)
  83.           #F)))))
  84.   (add-method dylan:initial-state
  85.     (one-arg 'DEQUE <deque>
  86.       (lambda (deque)
  87.     (dylan-call dylan:get-deque-front deque))))
  88.   (add-method dylan:initial-state
  89.     (one-arg 'RANGE <range>
  90.       (lambda (range)
  91.     (let ((start (dylan-call dylan:get-range-start range))
  92.           (end (dylan-call dylan:get-range-end range))
  93.           (step (dylan-call dylan:get-range-step range)))
  94.       (if end
  95.           (if ((if (negative? step) >= <=) start end)
  96.           start
  97.           #F)
  98.           start)))))
  99.   (add-method dylan:initial-state
  100.     (one-argbucket-left))
  101.            (let ((next-bucket (find-next-non-empty-bucket hash-table
  102.                                   hash-index)))
  103.          (if next-bucket
  104.              (list next-bucket (vector-ref hash-table next-bucket))
  105.              #F)))
  106.           (else (list hash-index (cdr bucket-left))))))))
  107.  
  108.   ;;
  109.   ;; PREVIOUS-STATE
  110.   ;;
  111.   (set! dylan:previous-state
  112.     (dylan::generic-fn 'previous-state one-collection-and-a-state #F))
  113.  
  114.   (add-method dylan:previous-state    ; Array => "Odometer style"
  115.     (dylan::function->method
  116.      (make-param-list `((ARRAY ,<array>) (STATE ,<sequence>)) #F #F #F)
  117.      (lambda (array state)
  118.        (let ((dimensions (dylan-call dylan:dimensions array)))
  119.      (let loop ((previous-state-indices state)
  120.             (dim-index (- (length dimensions) 1)))
  121.        (if (negative? dim-index)
  122.            #F
  123.            (if (< (vector-ref previous-state-indices dim-index) 1)
  124.            (loop previous-state-indices (- dim-index 1))
  125.            (begin
  126.              (vector-set! previous-state-indices dim-index
  127.                   (- (vector-ref previous-state-indices dim-index)
  128.                      1))
  129.              previous-state-indices))))))))
  130.   (add-method dylan:previous-state
  131.     (dylan::function->method
  132.      (make-param-list `((NULL ,<empty-list>) (STATE ,<object>)) #F #F #F)
  133.      (lambda (emp-list state) emp-list state #F)))
  134.  
  135. ;  (add-method dylan:previous-state    ; FOR EFFICIENCY ONLY!!
  136. ;    (dylan::function->method
  137. ;     (make-param-list `((SOV ,<simple-object-vector>) (STATE ,<sequence>)
  138. ;                              #F #F #F))
  139. ;     (lambda (vect state)
  140. ;       (cond ((not (pair? state))
  141. ;           (dylan-call dylan:error
  142. ;               "previous-state -- invalid state" vect state))
  143. ;         ((positive? (car state)) (list (- (car state) 1)))
  144. ;         ((zero? (car state)) #F)
  145. ;         (else (dylan-call dylan:error
  146. ;                   "previous-state -- invalid state"
  147. ;                   vect state))))))
  148.  
  149.   (add-method dylan:previous-state
  150.     (dylan::function->method
  151.      (make-param-list `((DEQUE ,<deque>) (STATE ,<object>)) #F #F #F)
  152.      (lambda (deque state)
  153.        deque                ; not used
  154.        (deque-entry.previous state))))
  155.   (add-method dylan:previous-state    ; Not defined in manual
  156.      (dylan::function->method
  157.       (make-param-list `((RANGE ,<range>) (STATE ,<object>)) #F #F #F)
  158.       (lambda (range state)
  159.     (let* ((start (dylan-call dylan:get-range-start range))
  160.            (step (dylan-call dylan:get-range-step range))
  161.            (prev (- state step)))
  162.      (if ((if (negative? step) > <) prev start)
  163.          #F
  164.          prev)))))
  165.  
  166.   ;;
  167.   ;; CURRENT-ELEMENT
  168.   ;;
  169.   (set! dylan:current-element
  170.     (dylan::generic-fn 'current-element one-collection-and-a-state
  171.        (lambda (collection state)
  172.      (dylan-call
  173.       dylan:error
  174.       "current-element -- not specialized for this collection type"
  175.       collection state))))
  176.  
  177.   (add-method dylan:current-element
  178.     (dylan::function->method
  179.      (make-param-list `((ARRAY ,<array>) (STATE ,<sequence>)) #F #F #F)
  180.      (lambda (array state)
  181.        (dylan-call dylan:element array state))))
  182.   (add-method dylan:current-element
  183.     (dylan::function->method
  184.      (make-param-list
  185.       `((SOV ,<simple-object-vector>) (STATE ,<sequence>)) #F #F #F)
  186.      (lambda (vec state)
  187.        (vector-ref vec (vector-ref state 0)))))
  188.   (add-method dylan:current-element
  189.     (dylan::function->method
  190.      (make-param-list `((LIST ,<list>) (STATE ,<object>)) #F #F #F)
  191.      (lambda (list state)
  192.        list                ; Ignored
  193.        (if (pair? state)
  194.        (car state)
  195.        state))))            ; If reached dotted list end...
  196.   (add-method dylan:current-element
  197.     (dylan::function->method
  198.      (make-param-list `((NULL ,<empty-list>) (STATE ,<sequence>)) #F #F #F)
  199.      (lambda (emp-list state) emp-list state #F)))
  200.   (add-method dylan:current-element
  201.     (dylan::function->method
  202.      (make-param-list
  203.       `((BYTE-STRING ,<byte-string>) (STATE ,<sequence>)) #F #F #F)
  204.      (lambda (string state)
  205.        (string-ref string (vector-ref state 0)))))
  206.   (add-method dylan:current-element
  207.     (dylan::function->method
  208.      (make-param-list `((DEQUE ,<deque>) (STATE ,<object>)) #F #F #F)
  209.      (lambda (deque state)
  210.        deque                ; not used
  211.        (deque-entry.value state))))
  212.   (add-method dylan:current-element
  213.     (dylan::function->method
  214.      (make-param-list `((RANGE ,<range>) (STATE ,<object>)) #F #F #F)
  215.      (lambda (range state)
  216.        range                ; not used
  217.        state)))
  218.   (add-method dylan:current-element
  219.     (dylan::function->method
  220.      (make-param-list `((TABLE ,<table>) (STATE ,<object>)) #F #F #F)
  221.      (lambda (table state)
  222.        table                ; Ignored
  223.        (cadr (car (cadr state))))))
  224.  
  225.   (set! dylan:copy-state
  226.     (dylan::generic-fn 'copy-state one-collection-and-a-state
  227.       (lambda (collection state)
  228.     collection            ; unused
  229.     state)))
  230.   )                    ; End of Iteration Functions
  231.  
  232.  
  233.  
  234.  
  235. ;; Iterate-Until: given a fn and a collection, iterate until
  236. ;; the collection runs out of elements or fn returns a non-#F value.
  237. (define (iterate-until fn collection)
  238.   (let loop ((state (dylan-call dylan:initial-state collection)))
  239.     (cond ((not state) #F)
  240.       ((fn (dylan-call dylan:current-element collection state)))
  241.       (else (loop
  242.          (dylan-call dylan:next-state collection state))))))
  243.  
  244. (define (iterate->list fn collection)
  245.   (let loop ((state (dylan-call dylan:initial-state collection))
  246.          (value '()))
  247.     (if state
  248.     (let ((new-value
  249.            (fn (dylan-call dylan:current-element collection state))))
  250.       (loop (dylan-call dylan:next-state collection state)
  251.         (cons new-value value)))
  252.     (reverse value))))
  253.  
  254. ;;;; The Iteration Protocol (page 122)
  255. ;;;; Actually, these are internal procedures used elsewhere to iterate
  256. ;;;; over collections or sets of collections
  257.  
  258. (define (collections-iterate fn done? default-value collections)
  259.   ;; FN is a Dylan function to be applied to parallel elements from
  260.   ;;    each collection.
  261.   ;; DONE? is a scheme function applied to the result of FN to test
  262.   ;;    for loop completion.  It returns #F to continue the iteration,
  263.   ;;    or a (Scheme) thunk to return the value.
  264.   ;; DEFAULT-VALUE is returned if any collection runs out before the
  265.   ;;    DONE? test causes an exit.
  266.   (if (not (all?
  267.         (lambda (collection)
  268.           (subclass? (get-type collection) <collection>))
  269.         collections))
  270.       (dylan-call dylan:error
  271.           "do -- not all arguments are collections" collections))
  272.   (let loop ((states
  273.           (map (lambda (collection)
  274.              (dylan-call dylan:initial-state collection))
  275.            collections)))
  276.     (if (any? (lambda (x) (not x)) states)
  277.     default-value
  278.     (let ((ins (map (lambda (collection state)
  279.               (dylan-call dylan:current-element collection state))
  280.             collections states)))
  281.       (let* ((next-val (dylan-apply fn ins))
  282.          (result? (done? next-val)))
  283.         (if result?
  284.         (result?)
  285.         (loop (map (lambda (collection state)
  286.                  (dylan-call dylan:next-state
  287.                      collection
  288.                      state))
  289.                collections states))))))))
  290.  
  291. (define (iterate! fn collection)
  292.   (let loop ((state (dylan-call dylan:initial-state collection)))
  293.     (if state
  294.     (begin
  295.       (fn (dylan-call dylan:current-element collection state))
  296.       (loop (dylan-call dylan:next-state collection state))))))
  297.  
  298. (define (find-next-non-empty-bucket hash-table index)
  299.   (let ((table-length (vector-length hash-table)))
  300.     (let loop ((i (+ index 1)))
  301.       (cond ((>= i table-length) #F)
  302.         ((null? (vector-ref hash-table i)) (loop (+ i 1)))
  303.         (else i)))))
  304.  
  305. ;;
  306. ;; DYLAN:GET-STATE: given a collection and a state index, return the
  307. ;;                  corresponding state.
  308. ;;                  initial-state = 0
  309. ;;                  If no corresponding state, return #F
  310. ;;
  311. (define dylan:get-state
  312.   (dylan::generic-fn 'get-state
  313.     (make-param-list `((COLLECTION ,<collection>) (INDEX ,<number>)) #F #F #F)
  314.     (lambda (collection index)
  315.       (do ((i 0 (+ i 1))
  316.        (state (dylan-call dylan:initial-state collection)
  317.           (dylan-call dylan:next-state collection state)))
  318.       ((or (= i index) (not state)) state)))))
  319.  
  320.  
  321. ;;;;
  322. ;;;; Collection Keys (page 123 )
  323. ;;;;
  324.  
  325. (define dylan:element
  326.   (dylan::generic-fn
  327.    'element
  328.    (make-param-list `((COLLECTION ,<collection>) (KEY ,<object>))
  329.             #F #F '(default:))
  330.    #F))
  331.  
  332. (add-method
  333.  dylan:element
  334.  (dylan::dylan-callable->method
  335.   (make-param-list `((COLLECTION ,<collection>) (KEY ,<object>))
  336.            #F #F '(default:))
  337.   (lambda (multiple-val